home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / siod / siod_v20.lha / slib.c < prev   
Encoding:
C/C++ Source or Header  |  1993-08-16  |  30.8 KB  |  1,295 lines
  1. /* Scheme In One Defun, but in C this time.
  2.  
  3.  *                        COPYRIGHT (c) 1989 BY                             *
  4.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  5.  *               ALL RIGHTS RESERVED                              *
  6.  
  7. Permission to use, copy, modify, and distribute this software and its
  8. documentation for any purpose and without fee is hereby granted,
  9. provided that the above copyright notice appear in all copies and that
  10. both that copyright notice and this permission notice appear in
  11. supporting documentation, and that the name of Paradigm Associates Inc
  12. not be used in advertising or publicity pertaining to distribution of
  13. the software without specific, written prior permission.
  14.  
  15. PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  16. ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  17. PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  18. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
  19. WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
  20. ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  21. SOFTWARE.
  22.  
  23. */
  24.  
  25. /*
  26.  
  27. gjc@paradigm.com
  28.  
  29. Paradigm Associates Inc          Phone: 617-492-6079
  30. 29 Putnam Ave, Suite 6
  31. Cambridge, MA 02138
  32.  
  33.  
  34.    Release 1.0: 24-APR-88
  35.    Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
  36.     Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
  37.     cleaned up uses of NULL/0. Now distributed with siod.scm.
  38.    Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU,
  39.     plus some bug fixes.
  40.    Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
  41.     define now works properly. vms specific function edit.
  42.    Release 1.4 20-NOV-89. Minor Cleanup and remodularization.
  43.     Now in 3 files, siod.h, slib.c, siod.c. Makes it easier to write your
  44.     own main loops. Some short-int changes for lightspeed C included.
  45.    Release 1.5 29-NOV-89. Added startup flag -g, select stop and copy
  46.     or mark-and-sweep garbage collection, which assumes that the stack/register
  47.     marking code is correct for your architecture. 
  48.    Release 2.0 1-DEC-89. Added repl_hooks, Catch, Throw. This is significantly
  49.     different enough (from 1.3) now that I'm calling it a major release.
  50.  
  51.   */
  52.  
  53. #include <stdio.h>
  54. #include <string.h>
  55. #include <ctype.h>
  56. #include <setjmp.h>
  57. #include <signal.h>
  58. #include <math.h>
  59. #ifdef vms
  60. #include <stdlib.h>
  61. #endif
  62.  
  63. #include "siod.h"
  64.  
  65. LISP heap_1,heap_2;
  66. LISP heap,heap_end,heap_org;
  67.  
  68. long heap_size = 5000;
  69. long old_heap_used;
  70. long which_heap;
  71. long gc_status_flag = 1;
  72. char *init_file = (char *) NULL;
  73. char tkbuffer[TKBUFFERN];
  74.  
  75. long gc_kind_copying = 1;
  76.  
  77. long gc_cells_allocated = 0;
  78. double gc_time_taken;
  79. LISP *stack_start_ptr;
  80. LISP freelist;
  81.  
  82. jmp_buf errjmp;
  83. long errjmp_ok = 0;
  84. long nointerrupt = 1;
  85. long interrupt_differed = 0;
  86.  
  87. LISP oblist = NIL;
  88. LISP truth = NIL;
  89. LISP eof_val = NIL;
  90. LISP sym_errobj = NIL;
  91. LISP sym_progn = NIL;
  92. LISP sym_lambda = NIL;
  93. LISP sym_quote = NIL;
  94. LISP open_files = NIL;
  95. LISP unbound_marker = NIL;
  96.  
  97. struct catch_frame
  98. {LISP tag;
  99.  LISP retval;
  100.  jmp_buf cframe;
  101.  struct catch_frame *next;};
  102.  
  103. struct gc_protected
  104. {LISP *location;
  105.  struct gc_protected *next;};
  106.  
  107. struct catch_frame *catch_framep = (struct catch_frame *) NULL;
  108.  
  109.  
  110. process_cla(argc,argv)
  111.  int argc; char **argv;
  112. {int k;
  113.  for(k=1;k<argc;++k)
  114.    {if (strlen(argv[k])<2) continue;
  115.     if (argv[k][0] != '-') {printf("bad arg: %s\n",argv[k]);continue;}
  116.     switch(argv[k][1])
  117.       {case 'h':
  118.      heap_size = atol(&(argv[k][2])); break;
  119.        case 'i':
  120.      init_file = &(argv[k][2]); break;
  121.        case 'g':
  122.      gc_kind_copying = atol(&(argv[k][2])); break;
  123.        default: printf("bad arg: %s\n",argv[k]);}}}
  124.  
  125. print_welcome()
  126. {printf("Welcome to SIOD, Scheme In One Defun, Version 2.0\n");
  127.  printf("(C) Copyright 1988, 1989 Paradigm Associates Inc.\n");}
  128.  
  129. print_hs_1()
  130. {printf("heap_size = %ld cells, %ld bytes. GC is %s\n",
  131.         heap_size,heap_size*sizeof(struct obj),
  132.     (gc_kind_copying == 1) ? "stop and copy" : "mark and sweep");}
  133.  
  134. print_hs_2()
  135. {if (gc_kind_copying == 1)
  136.    printf("heap_1 at 0x%lX, heap_2 at 0x%lX\n",heap_1,heap_2);
  137.  else
  138.    printf("heap_1 at 0x%lX\n",heap_1);}
  139.  
  140. long no_interrupt(n)
  141.      long n;
  142. {long x;
  143.  x = nointerrupt;
  144.  nointerrupt = n;
  145.  if ((nointerrupt == 0) && (interrupt_differed == 1))
  146.    {interrupt_differed = 0;
  147.     err_ctrl_c();}
  148.  return(x);}
  149.  
  150.  
  151.  
  152. handle_sigfpe(sig,code,scp)
  153.  long sig,code; struct sigcontext *scp;
  154. {signal(SIGFPE,handle_sigfpe);
  155.  err("floating point exception",NIL);}
  156.  
  157. handle_sigint(sig,code,scp)
  158.  long sig,code; struct sigcontext *scp;
  159. {signal(SIGINT,handle_sigint);
  160.  if (nointerrupt == 1)
  161.    interrupt_differed = 1;
  162.  else
  163.    err_ctrl_c();}
  164.  
  165. err_ctrl_c()
  166. {err("control-c interrupt",NIL);}
  167.  
  168. LISP get_eof_val()
  169. {return(eof_val);}
  170.  
  171. repl_driver(want_sigint,want_init)
  172.      long want_sigint,want_init;
  173. {int k;
  174.  LISP stack_start;
  175.  stack_start_ptr = &stack_start;
  176.  k = setjmp(errjmp);
  177.  if (k == 2) return;
  178.  if (want_sigint) signal(SIGFPE,handle_sigfpe);
  179.  signal(SIGINT,handle_sigint);
  180.  close_open_files();
  181.  catch_framep = (struct catch_frame *) NULL;
  182.  errjmp_ok = 1;
  183.  interrupt_differed = 0;
  184.  nointerrupt = 0;
  185.  if (want_init && init_file && (k == 0)) vload(init_file);
  186.  repl();}
  187.  
  188. #ifdef unix
  189. #include <sys/types.h>
  190. #include <sys/times.h>
  191. struct tms time_buffer;
  192. double myruntime()
  193. {times(&time_buffer);
  194.  return(time_buffer.tms_utime/60.0);}
  195. #else
  196. #ifdef vms
  197. #include <time.h>
  198. double myruntime()
  199. {return(clock() * 1.0e-2);}
  200. #else
  201. double myruntime()
  202. {long x;
  203.  long time();
  204.  time(&x);
  205.  return((double) x);}
  206. #endif
  207. #endif
  208.  
  209.  
  210. void (*repl_puts)() = NULL;
  211. LISP (*repl_read)() = NULL;
  212. LISP (*repl_eval)() = NULL;
  213. void (*repl_print)() = NULL;
  214.  
  215. void set_repl_hooks(puts_f,read_f,eval_f,print_f)
  216.      void (*puts_f)();
  217.      LISP (*read_f)();
  218.      LISP (*eval_f)();
  219.      void (*print_f)();
  220. {repl_puts = puts_f;
  221.  repl_read = read_f;
  222.  repl_eval = eval_f;
  223.  repl_print = print_f;}
  224.  
  225. grepl_puts(st)
  226.      char *st;
  227. {if (repl_puts == NULL)
  228.    printf("%s",st);
  229.  else
  230.    (*repl_puts)(st);}
  231.      
  232. repl() 
  233. {LISP x,cw;
  234.  double rt;
  235.  while(1)
  236.    {if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
  237.      {rt = myruntime();
  238.       gc_stop_and_copy();
  239.       sprintf(tkbuffer,
  240.           "GC took %g seconds, %ld compressed to %ld, %ld free\n",
  241.           myruntime()-rt,old_heap_used,heap-heap_org,heap_end-heap);
  242.       grepl_puts(tkbuffer);}
  243.     grepl_puts("> ");
  244.     if (repl_read == NULL) x = lread();
  245.     else x = (*repl_read)();
  246.     if EQ(x,eof_val) break;
  247.     rt = myruntime();
  248.     if (gc_kind_copying == 1)
  249.       cw = heap;
  250.     else
  251.       {gc_cells_allocated = 0;
  252.        gc_time_taken = 0.0;}
  253.     if (repl_eval == NULL) x = leval(x,NIL);
  254.     else x = (*repl_eval)();
  255.     if (gc_kind_copying == 1)
  256.       sprintf(tkbuffer,
  257.           "Evaluation took %g seconds %ld cons work\n",
  258.           myruntime()-rt,
  259.           heap-cw);
  260.     else
  261.       sprintf(tkbuffer,
  262.           "Evaluation took %g seconds (%g in gc) %ld cons work\n",
  263.           myruntime()-rt,
  264.           gc_time_taken,
  265.           gc_cells_allocated);
  266.     grepl_puts(tkbuffer);
  267.     if (repl_print == NULL) lprint(x);
  268.     else (*repl_print)(x);}}
  269.  
  270. err(message,x)
  271.  char *message; LISP x;
  272. {nointerrupt = 1;
  273.  if NNULLP(x) 
  274.     printf("ERROR: %s (see errobj)\n",message);
  275.   else printf("ERROR: %s\n",message);
  276.  if (errjmp_ok == 1) {setvar(sym_errobj,x,NIL); longjmp(errjmp,1);}
  277.  printf("FATAL ERROR DURING STARTUP OR CRITICAL CODE SECTION\n");
  278.  exit(1);}
  279.  
  280.  
  281. LISP lerr(message,x)
  282.      LISP message,x;
  283. {if NSYMBOLP(message) err("argument to error not a symbol",message);
  284.  err(PNAME(message),x);
  285.  return(NIL);}
  286.  
  287. void gc_fatal_error()
  288. {err("ran out of storage",NIL);}
  289.  
  290. #define NEWCELL(_into,_type)          \
  291. {if (gc_kind_copying == 1)            \
  292.    {if ((_into = heap) >= heap_end)   \
  293.       gc_fatal_error();               \
  294.     heap = _into+1;}                  \
  295.  else                                 \
  296.    {if NULLP(freelist)                \
  297.       gc_for_newcell();               \
  298.     _into = freelist;                 \
  299.     freelist = CDR(freelist);         \
  300.     ++gc_cells_allocated;}            \
  301.  (*_into).gc_mark = 0;                \
  302.  (*_into).type = _type;}
  303.       
  304.  
  305. LISP cons(x,y)
  306.      LISP x,y;
  307. {LISP z;
  308.  NEWCELL(z,tc_cons);
  309.  CAR(z) = x;
  310.  CDR(z) = y;
  311.  return(z);}
  312.  
  313. LISP consp(x)
  314.      LISP x;
  315. {if CONSP(x) return(truth); else return(NIL);}
  316.  
  317. LISP car(x)
  318.      LISP x;
  319. {switch TYPE(x)
  320.    {case tc_nil:
  321.       return(NIL);
  322.     case tc_cons:
  323.       return(CAR(x));
  324.     default:
  325.       err("wta to car",x);}}
  326.  
  327. LISP cdr(x)
  328.      LISP x;
  329. {switch TYPE(x)
  330.    {case tc_nil:
  331.       return(NIL);
  332.     case tc_cons:
  333.       return(CDR(x));
  334.     default:
  335.       err("wta to cdr",x);}}
  336.  
  337.  
  338. LISP setcar(cell,value)
  339.      LISP cell, value;
  340. {if NCONSP(cell) err("wta to setcar",cell);
  341.  return(CAR(cell) = value);}
  342.  
  343. LISP setcdr(cell,value)
  344.      LISP cell, value;
  345. {if NCONSP(cell) err("wta to setcdr",cell);
  346.  return(CDR(cell) = value);}
  347.  
  348. LISP flocons(x)
  349.  double x;
  350. {LISP z;
  351.  NEWCELL(z,tc_flonum);
  352.  (*z).storage_as.flonum.data = x;
  353.  return(z);}
  354.  
  355. LISP numberp(x)
  356.      LISP x;
  357. {if FLONUMP(x) return(truth); else return(NIL);}
  358.  
  359. LISP plus(x,y)
  360.      LISP x,y;
  361. {if NFLONUMP(x) err("wta(1st) to plus",x);
  362.  if NFLONUMP(y) err("wta(2nd) to plus",y);
  363.  return(flocons(FLONM(x)+FLONM(y)));}
  364.  
  365. LISP ltimes(x,y)
  366.  LISP x,y;
  367. {if NFLONUMP(x) err("wta(1st) to times",x);
  368.  if NFLONUMP(y) err("wta(2nd) to times",y);
  369.  return(flocons(FLONM(x)*FLONM(y)));}
  370.  
  371. LISP difference(x,y)
  372.  LISP x,y;
  373. {if NFLONUMP(x) err("wta(1st) to difference",x);
  374.  if NFLONUMP(y) err("wta(2nd) to difference",y);
  375.  return(flocons(FLONM(x)-FLONM(y)));}
  376.  
  377. LISP quotient(x,y)
  378.  LISP x,y;
  379. {if NFLONUMP(x) err("wta(1st) to quotient",x);
  380.  if NFLONUMP(y) err("wta(2nd) to quotient",y);
  381.  return(flocons(FLONM(x)/FLONM(y)));}
  382.  
  383. LISP greaterp(x,y)
  384.  LISP x,y;
  385. {if NFLONUMP(x) err("wta(1st) to greaterp",x);
  386.  if NFLONUMP(y) err("wta(2nd) to greaterp",y);
  387.  if (FLONM(x)>FLONM(y)) return(truth);
  388.  return(NIL);}
  389.  
  390. LISP lessp(x,y)
  391.  LISP x,y;
  392. {if NFLONUMP(x) err("wta(1st) to lessp",x);
  393.  if NFLONUMP(y) err("wta(2nd) to lessp",y);
  394.  if (FLONM(x)<FLONM(y)) return(truth);
  395.  return(NIL);}
  396.  
  397. LISP eq(x,y)
  398.  LISP x,y;
  399. {if EQ(x,y) return(truth); else return(NIL);}
  400.  
  401. LISP eql(x,y)
  402.  LISP x,y;
  403. {if EQ(x,y) return(truth); else 
  404.  if NFLONUMP(x) return(NIL); else
  405.  if NFLONUMP(y) return(NIL); else
  406.  if (FLONM(x) == FLONM(y)) return(truth);
  407.  return(NIL);}
  408.  
  409. LISP symcons(pname,vcell)
  410.  char *pname; LISP vcell;
  411. {LISP z;
  412.  NEWCELL(z,tc_symbol);
  413.  PNAME(z) = pname;
  414.  VCELL(z) = vcell;
  415.  return(z);}
  416.  
  417. LISP symbolp(x)
  418.      LISP x;
  419. {if SYMBOLP(x) return(truth); else return(NIL);}
  420.  
  421. LISP symbol_boundp(x,env)
  422.  LISP x,env;
  423. {LISP tmp;
  424.  if NSYMBOLP(x) err("not a symbol",x);
  425.  tmp = envlookup(x,env);
  426.  if NNULLP(tmp) return(truth);
  427.  if EQ(VCELL(x),unbound_marker) return(NIL); else return(truth);}
  428.  
  429. LISP symbol_value(x,env)
  430.  LISP x,env;
  431. {LISP tmp;
  432.  if NSYMBOLP(x) err("not a symbol",x);
  433.  tmp = envlookup(x,env);
  434.  if NNULLP(tmp) return(CAR(tmp));
  435.  tmp = VCELL(x);
  436.  if EQ(tmp,unbound_marker) err("unbound variable",x);
  437.  return(tmp);}
  438.  
  439. LISP cintern_soft(name)
  440.  char *name;
  441. {LISP l;
  442.  for(l=oblist;NNULLP(l);l=CDR(l))
  443.    if (strcmp(name,PNAME(CAR(l))) == 0) return(CAR(l));
  444.  return(NIL);}
  445.  
  446. LISP cintern(name)
  447.  char *name;
  448. {LISP sym;
  449.  sym = cintern_soft(name);
  450.  if(sym) return(sym);
  451.  sym = symcons(name,unbound_marker);
  452.  oblist = cons(sym,oblist);
  453.  return(sym);}
  454.  
  455. char * must_malloc(size)
  456.      unsigned long size;
  457. {char *tmp;
  458.  tmp = (char *) malloc(size);
  459.  if (tmp == (char *)NULL) err("failed to allocate storage from system",NIL);
  460.  return(tmp);}
  461.  
  462. LISP rintern(name)
  463.  char *name;
  464. {LISP sym;
  465.  char *newname;
  466.  sym = cintern_soft(name);
  467.  if(sym) return(sym);
  468.  newname = must_malloc(strlen(name)+1);
  469.  strcpy(newname,name);
  470.  sym = symcons(newname,unbound_marker);
  471.  oblist = cons(sym,oblist);
  472.  return(sym);}
  473.  
  474. LISP subrcons(type,name,f)
  475.  long type; char *name; LISP (*f)();
  476. {LISP z;
  477.  NEWCELL(z,type);
  478.  (*z).storage_as.subr.name = name;
  479.  (*z).storage_as.subr.f = f;
  480.  return(z);}
  481.  
  482.  
  483. LISP closure(env,code)
  484.      LISP env,code;
  485. {LISP z;
  486.  NEWCELL(z,tc_closure);
  487.  (*z).storage_as.closure.env = env;
  488.  (*z).storage_as.closure.code = code;
  489.  return(z);}
  490.  
  491.  
  492. struct gc_protected *protected_registers = NULL;
  493.  
  494. void gc_protect(location)
  495.  LISP *location;
  496. {struct gc_protected *reg;
  497.  reg = (struct gc_protected *) must_malloc(sizeof(struct gc_protected));
  498.  (*reg).location = location;
  499.  (*reg).next = protected_registers;
  500.   protected_registers = reg;}
  501.  
  502. scan_registers()
  503. {struct gc_protected *reg;
  504.  for(reg = protected_registers; reg; reg = (*reg).next)
  505.    *((*reg).location) = gc_relocate(*((*reg).location));}
  506.  
  507. init_storage()
  508. {LISP ptr,next,end;
  509.  heap_1 = (LISP) must_malloc(sizeof(struct obj)*heap_size);
  510.  heap = heap_1;
  511.  which_heap = 1;
  512.  heap_org = heap;
  513.  heap_end = heap + heap_size;
  514.  if (gc_kind_copying == 1)
  515.    heap_2 = (LISP) must_malloc(sizeof(struct obj)*heap_size);
  516.  else
  517.    {ptr = heap_org;
  518.     end = heap_end;
  519.     while(1)
  520.       {(*ptr).type = tc_free_cell;
  521.        next = ptr + 1;
  522.        if (next < end)
  523.      {CDR(ptr) = next;
  524.       ptr = next;}
  525.        else
  526.      {CDR(ptr) = NIL;
  527.       break;}}
  528.     freelist = heap_org;}
  529.  unbound_marker = cons(cintern("**unbound-marker**"),NIL);
  530.  gc_protect(&unbound_marker);
  531.  eof_val = cons(cintern("eof"),NIL);
  532.  gc_protect(&eof_val);
  533.  truth = cintern("t");
  534.  gc_protect(&truth);
  535.  setvar(truth,truth,NIL);
  536.  setvar(cintern("nil"),NIL,NIL);
  537.  setvar(cintern("let"),cintern("let-internal-macro"),NIL);
  538.  sym_errobj = cintern("errobj");
  539.  gc_protect(&sym_errobj);
  540.  setvar(sym_errobj,NIL,NIL);
  541.  sym_progn = cintern("begin");
  542.  gc_protect(&sym_progn);
  543.  sym_lambda = cintern("lambda");
  544.  gc_protect(&sym_lambda);
  545.  sym_quote = cintern("quote");
  546.  gc_protect(&sym_quote);
  547.  gc_protect(&oblist);
  548.  gc_protect(&open_files);}
  549.  
  550. void init_subr(name,type,fcn)
  551.  char *name; long type; LISP (*fcn)();
  552. {setvar(cintern(name),subrcons(type,name,fcn),NIL);}
  553.  
  554. LISP assq(x,alist)
  555.      LISP x,alist;
  556. {LISP l,tmp;
  557.  for(l=alist;CONSP(l);l=CDR(l))
  558.    {tmp = CAR(l);
  559.     if (CONSP(tmp) && EQ(CAR(tmp),x)) return(tmp);}
  560.  if EQ(l,NIL) return(NIL);
  561.  err("improper list to assq",alist);}
  562.  
  563. LISP gc_relocate(x)
  564.      LISP x;
  565. {LISP new;
  566.  if EQ(x,NIL) return(NIL);
  567.  if ((*x).gc_mark == 1) return(CAR(x));
  568.  switch TYPE(x)
  569.    {case tc_flonum:
  570.       new = flocons(FLONM(x));
  571.       break;
  572.     case tc_cons:
  573.       new = cons(CAR(x),CDR(x));
  574.       break;
  575.     case tc_symbol:
  576.       new = symcons(PNAME(x),VCELL(x));
  577.       break;
  578.     case tc_closure:
  579.       new = closure((*x).storage_as.closure.env,
  580.             (*x).storage_as.closure.code);
  581.       break;
  582.     case tc_subr_0:
  583.     case tc_subr_1:
  584.     case tc_subr_2:
  585.     case tc_subr_3:
  586.     case tc_lsubr:
  587.     case tc_fsubr:
  588.     case tc_msubr:
  589.       new = subrcons(TYPE(x),
  590.              (*x).storage_as.subr.name,
  591.              (*x).storage_as.subr.f);
  592.       break;
  593.     default: err("BUG IN GARBAGE COLLECTOR gc_relocate",NIL);}
  594.  (*x).gc_mark = 1;
  595.  CAR(x) = new;
  596.  return(new);}
  597.  
  598. LISP get_newspace()
  599. {LISP newspace;
  600.  if (which_heap == 1)
  601.    {newspace = heap_2;
  602.     which_heap = 2;}
  603.  else
  604.    {newspace = heap_1;
  605.     which_heap = 1;}
  606.  heap = newspace;
  607.  heap_org = heap;
  608.  heap_end = heap + heap_size;
  609.  return(newspace);}
  610.  
  611. scan_newspace(newspace)
  612.      LISP newspace;
  613. {LISP ptr;
  614.  for(ptr=newspace; ptr < heap; ++ptr)
  615.    {switch TYPE(ptr)
  616.       {case tc_cons:
  617.        case tc_closure:
  618.      CAR(ptr) = gc_relocate(CAR(ptr));
  619.      CDR(ptr) = gc_relocate(CDR(ptr));
  620.      break;
  621.        case tc_symbol:
  622.      VCELL(ptr) = gc_relocate(VCELL(ptr));
  623.      break;
  624.        default:
  625.      break;}}}
  626.       
  627. gc_stop_and_copy()
  628. {LISP newspace;
  629.  long flag;
  630.  flag = no_interrupt(1);
  631.  errjmp_ok = 0;
  632.  old_heap_used = heap - heap_org;
  633.  newspace = get_newspace();
  634.  scan_registers();
  635.  scan_newspace(newspace);
  636.  errjmp_ok = 1;
  637.  no_interrupt(flag);}
  638.  
  639. gc_for_newcell()
  640. {long flag;
  641.  if (errjmp_ok == 0) gc_fatal_error();
  642.  flag = no_interrupt(1);
  643.  errjmp_ok = 0;
  644.  gc_mark_and_sweep();
  645.  errjmp_ok = 1;
  646.  no_interrupt(flag);
  647.  if NULLP(freelist) gc_fatal_error();}
  648.  
  649. jmp_buf save_regs_gc_mark;
  650.  
  651. gc_mark_and_sweep()
  652. {LISP stack_end;
  653.  gc_ms_stats_start();
  654.  /* This assumes that all registers are saved into the jmp_buff */
  655.  setjmp(save_regs_gc_mark);
  656.  mark_locations(save_regs_gc_mark,
  657.         ((char *) save_regs_gc_mark) + sizeof(save_regs_gc_mark));
  658.  mark_protected_registers();
  659.  mark_locations(stack_start_ptr,&stack_end);
  660.  gc_sweep();
  661.  gc_ms_stats_end();}
  662.  
  663. double gc_rt;
  664. long gc_cells_collected;
  665.  
  666. gc_ms_stats_start()
  667. {gc_rt = myruntime();
  668.  gc_cells_collected = 0;
  669.  if (gc_status_flag)
  670.    printf("[starting GC]\n");}
  671.  
  672. gc_ms_stats_end()
  673. {gc_rt = myruntime() - gc_rt;
  674.  gc_time_taken = gc_time_taken + gc_rt;
  675.  if (gc_status_flag)
  676.    printf("[GC took %g cpu seconds, %ld cells collected]\n",
  677.       gc_rt,
  678.       gc_cells_collected);}
  679.  
  680.  
  681. void gc_mark(ptr)
  682.      LISP ptr;
  683. {gc_mark_loop:
  684.  if NULLP(ptr) return;
  685.  if ((*ptr).gc_mark) return;
  686.  (*ptr).gc_mark = 1;
  687.  switch ((*ptr).type)
  688.    {case tc_flonum:
  689.       break;
  690.     case tc_cons:
  691.       gc_mark(CAR(ptr));
  692.       ptr = CDR(ptr);
  693.       goto gc_mark_loop;
  694.     case tc_symbol:
  695.       ptr = VCELL(ptr);
  696.       goto gc_mark_loop;
  697.     case tc_closure:
  698.       gc_mark((*ptr).storage_as.closure.env);
  699.       ptr = (*ptr).storage_as.closure.code;
  700.       goto gc_mark_loop;
  701.     case tc_subr_0:
  702.     case tc_subr_1:
  703.     case tc_subr_2:
  704.     case tc_subr_3:
  705.     case tc_lsubr:
  706.     case tc_fsubr:
  707.     case tc_msubr:
  708.       return;
  709.     default:
  710.       err("BUG IN GARBAGE COLLECTOR gc_mark",NIL);}}
  711.  
  712. mark_protected_registers()
  713. {struct gc_protected *reg;
  714.  for(reg = protected_registers; reg; reg = (*reg).next)
  715.    gc_mark(*((*reg).location));}
  716.  
  717.  
  718. mark_locations(start,end)
  719.      LISP *start,*end;
  720. {LISP *tmp;
  721.  long n;
  722.  if (start > end)
  723.    {tmp = start;
  724.     start = end;
  725.     end = tmp;}
  726.  n = end - start;
  727.  mark_locations_array(start,n);}
  728.  
  729. mark_locations_array(x,n)
  730.      LISP x[];
  731.      long n;
  732. {int j;
  733.  LISP p;
  734.  for(j=0;j<n;++j)
  735.    {p = x[j];
  736.     if ((p >= heap_org) &&
  737.     (p < heap_end) &&
  738.     (((((char *)p) - ((char *)heap_org)) % sizeof(struct obj)) == 0) &&
  739.     NTYPEP(p,tc_free_cell))
  740.       gc_mark(p);}}
  741.  
  742.  
  743. gc_sweep()
  744. {LISP ptr,end,nfreelist;
  745.  long n;
  746.  end = heap_end;
  747.  n = 0;
  748.  nfreelist = freelist;
  749.  for(ptr=heap_org; ptr < end; ++ptr)
  750.    if (((*ptr).gc_mark == 0) &&
  751.        ((*ptr).type != tc_free_cell))
  752.      {++n;
  753.       (*ptr).type = tc_free_cell;
  754.       CDR(ptr) = nfreelist;
  755.       nfreelist = ptr;}
  756.    else
  757.      (*ptr).gc_mark = 0;
  758.  gc_cells_collected = n;
  759.  freelist = nfreelist;}
  760.  
  761.  
  762. LISP user_gc(args)
  763.      LISP args;
  764. {long old_status_flag,flag;
  765.  if (gc_kind_copying == 1)
  766.    err("implementation cannot GC at will with stop-and-copy\n",
  767.        NIL);
  768.  flag = no_interrupt(1);
  769.  errjmp_ok = 0;
  770.  old_status_flag = gc_status_flag;
  771.  if NNULLP(args)
  772.    if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
  773.  gc_mark_and_sweep();
  774.  gc_status_flag = old_status_flag;
  775.  errjmp_ok = 1;
  776.  no_interrupt(flag);
  777.  return(NIL);}
  778.  
  779.  
  780. LISP gc_status(args)
  781.      LISP args;
  782. {LISP l;
  783.  int n;
  784.  if NNULLP(args) 
  785.    if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
  786.  if (gc_kind_copying == 1)
  787.    {if (gc_status_flag)
  788.       printf("garbage collection is on\n");
  789.    else
  790.      printf("garbage collection is off\n");
  791.     printf("%ld allocated %ld free\n",heap - heap_org, heap_end - heap);}
  792.  else
  793.    {if (gc_status_flag)
  794.       printf("garbage collection verbose\n");
  795.     else
  796.       printf("garbage collection silent\n");
  797.     {for(n=0,l=freelist;NNULLP(l); ++n) l = CDR(l);
  798.      printf("%ld allocated %ld free\n",(heap_end - heap_org) - n,n);}}
  799.  return(NIL);}
  800.  
  801. LISP leval_args(l,env)
  802.      LISP l,env;
  803. {LISP result,v1,v2,tmp;
  804.  if NULLP(l) return(NIL);
  805.  if NCONSP(l) err("bad syntax argument list",l);
  806.  result = cons(leval(CAR(l),env),NIL);
  807.  for(v1=result,v2=CDR(l);
  808.      CONSP(v2);
  809.      v1 = tmp, v2 = CDR(v2))
  810.   {tmp = cons(leval(CAR(v2),env),NIL);
  811.    CDR(v1) = tmp;}
  812.  if NNULLP(v2) err("bad syntax argument list",l);
  813.  return(result);}
  814.  
  815. LISP extend_env(actuals,formals,env)
  816.  LISP actuals,formals,env;
  817. {if SYMBOLP(formals)
  818.    return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
  819.  return(cons(cons(formals,actuals),env));}
  820.  
  821. LISP envlookup(var,env)
  822.  LISP var,env;
  823. {LISP frame,al,fl,tmp;
  824.  for(frame=env;CONSP(frame);frame=CDR(frame))
  825.    {tmp = CAR(frame);
  826.     if NCONSP(tmp) err("damaged frame",tmp);
  827.     for(fl=CAR(tmp),al=CDR(tmp);
  828.     CONSP(fl);
  829.     fl=CDR(fl),al=CDR(al))
  830.       {if NCONSP(al) err("too few arguments",tmp);
  831.        if EQ(CAR(fl),var) return(al);}}
  832.  if NNULLP(frame) err("damaged env",env);
  833.  return(NIL);}
  834.  
  835. LISP leval(x,env)
  836.  LISP x,env;
  837. {LISP tmp,arg1;
  838.  loop:
  839.  switch TYPE(x)
  840.    {case tc_symbol:
  841.       tmp = envlookup(x,env);
  842.       if (tmp) return(CAR(tmp));
  843.       tmp = VCELL(x);
  844.       if EQ(tmp,unbound_marker) err("unbound variable",x);
  845.       return(tmp);
  846.     case tc_cons:
  847.       tmp = leval(CAR(x),env);
  848.       switch TYPE(tmp)
  849.     {case tc_subr_0:
  850.        return(SUBRF(tmp)());
  851.      case tc_subr_1:
  852.        return(SUBRF(tmp)(leval(car(CDR(x)),env)));
  853.      case tc_subr_2:
  854.        x = CDR(x);
  855.        arg1 = leval(car(x),env);
  856.        x = NULLP(x) ? NIL : CDR(x);
  857.        return(SUBRF(tmp)(arg1,
  858.                  leval(car(x),env)));
  859.      case tc_subr_3:
  860.        x = CDR(x);
  861.        arg1 = leval(car(x),env);
  862.        x = NULLP(x) ? NIL : CDR(x);
  863.        return(SUBRF(tmp)(arg1,
  864.                  leval(car(x),env),
  865.                  leval(car(cdr(x)),env)));
  866.      case tc_lsubr:
  867.        return(SUBRF(tmp)(leval_args(CDR(x),env)));
  868.      case tc_fsubr:
  869.        return(SUBRF(tmp)(CDR(x),env));
  870.      case tc_msubr:
  871.        if NULLP(SUBRF(tmp)(&x,&env)) return(x);
  872.        goto loop;
  873.      case tc_closure:
  874.        env = extend_env(leval_args(CDR(x),env),
  875.                 car((*tmp).storage_as.closure.code),
  876.                 (*tmp).storage_as.closure.env);
  877.        x = cdr((*tmp).storage_as.closure.code);
  878.        goto loop;
  879.      case tc_symbol:
  880.        x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
  881.        x = leval(x,NIL);
  882.        goto loop;
  883.      default:
  884.        err("bad function",tmp);}
  885.     default:
  886.       return(x);}}
  887.  
  888. LISP setvar(var,val,env)
  889.  LISP var,val,env;
  890. {LISP tmp;
  891.  if NSYMBOLP(var) err("wta(non-symbol) to setvar",var);
  892.  tmp = envlookup(var,env);
  893.  if NULLP(tmp) return(VCELL(var) = val);
  894.  return(CAR(tmp)=val);}
  895.  
  896.  
  897. LISP leval_setq(args,env)
  898.  LISP args,env;
  899. {return(setvar(car(args),leval(car(cdr(args)),env),env));}
  900.  
  901. LISP syntax_define(args)
  902.  LISP args;
  903. {if SYMBOLP(car(args)) return(args);
  904.  return(syntax_define(
  905.         cons(car(car(args)),
  906.     cons(cons(sym_lambda,
  907.          cons(cdr(car(args)),
  908.           cdr(args))),
  909.          NIL))));}
  910.       
  911. LISP leval_define(args,env)
  912.  LISP args,env;
  913. {LISP tmp,var,val;
  914.  tmp = syntax_define(args);
  915.  var = car(tmp);
  916.  if NSYMBOLP(var) err("wta(non-symbol) to define",var);
  917.  val = leval(car(cdr(tmp)),env);
  918.  tmp = envlookup(var,env);
  919.  if NNULLP(tmp) return(CAR(tmp) = val);
  920.  if NULLP(env) return(VCELL(var) = val);
  921.  tmp = car(env);
  922.  setcar(tmp,cons(var,car(tmp)));
  923.  setcdr(tmp,cons(val,cdr(tmp)));
  924.  return(val);}
  925.  
  926. LISP leval_if(pform,penv)
  927.  LISP *pform,*penv;
  928. {LISP args,env;
  929.  args = cdr(*pform);
  930.  env = *penv;
  931.  if NNULLP(leval(car(args),env)) 
  932.     *pform = car(cdr(args)); else *pform = car(cdr(cdr(args)));
  933.  return(truth);}
  934.  
  935. LISP leval_lambda(args,env)
  936.  LISP args,env;
  937. {LISP body;
  938.  if NULLP(cdr(cdr(args)))
  939.    body = car(cdr(args));
  940.   else body = cons(sym_progn,cdr(args));
  941.  return(closure(env,cons(arglchk(car(args)),body)));}
  942.                          
  943. LISP leval_progn(pform,penv)
  944.  LISP *pform,*penv;
  945. {LISP env,l,next;
  946.  env = *penv;
  947.  l = cdr(*pform);
  948.  next = cdr(l);
  949.  while(NNULLP(next)) {leval(car(l),env);l=next;next=cdr(next);}
  950.  *pform = car(l); 
  951.  return(truth);}
  952.  
  953. LISP leval_or(pform,penv)
  954.  LISP *pform,*penv;
  955. {LISP env,l,next,val;
  956.  env = *penv;
  957.  l = cdr(*pform);
  958.  next = cdr(l);
  959.  while(NNULLP(next))
  960.    {val = leval(car(l),env);
  961.     if NNULLP(val) {*pform = val; return(NIL);}
  962.     l=next;next=cdr(next);}
  963.  *pform = car(l); 
  964.  return(truth);}
  965.  
  966. LISP leval_and(pform,penv)
  967.  LISP *pform,*penv;
  968. {LISP env,l,next;
  969.  env = *penv;
  970.  l = cdr(*pform);
  971.  if NULLP(l) {*pform = truth; return(NIL);}
  972.  next = cdr(l);
  973.  while(NNULLP(next))
  974.    {if NULLP(leval(car(l),env)) {*pform = NIL; return(NIL);}
  975.     l=next;next=cdr(next);}
  976.  *pform = car(l); 
  977.  return(truth);}
  978.  
  979. LISP leval_catch(args,env)
  980.  LISP args,env;
  981. {struct catch_frame frame;
  982.  int k;
  983.  LISP l,val;
  984.  frame.tag = leval(car(args),env);
  985.  frame.next = catch_framep;
  986.  k = setjmp(frame.cframe);
  987.  catch_framep = &frame;
  988.  if (k == 2)
  989.    {catch_framep = frame.next;
  990.     return(frame.retval);}
  991.  for(l=cdr(args); NNULLP(l); l = cdr(l))
  992.    val = leval(car(l),env);
  993.  catch_framep = frame.next;
  994.  return(val);}
  995.  
  996. LISP lthrow(tag,value)
  997.      LISP tag,value;
  998. {struct catch_frame *l;
  999.  for(l=catch_framep; l; l = (*l).next)
  1000.    if EQ((*l).tag,tag)
  1001.      {(*l).retval = value;
  1002.       longjmp((*l).cframe,2);}
  1003.  err("no *catch found with this tag",tag);
  1004.  return(NIL);}
  1005.  
  1006. LISP leval_let(pform,penv)
  1007.  LISP *pform,*penv;
  1008. {LISP env,l;
  1009.  l = cdr(*pform);
  1010.  env = *penv;
  1011.  *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
  1012.  *pform = car(cdr(cdr(l)));
  1013.  return(truth);}
  1014.  
  1015. LISP reverse(l)
  1016.  LISP l;
  1017. {LISP n,p;
  1018.  n = NIL;
  1019.  for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
  1020.  return(n);}
  1021.  
  1022. LISP let_macro(form)
  1023.  LISP form;
  1024. {LISP p,fl,al,tmp;
  1025.  fl = NIL;
  1026.  al = NIL;
  1027.  for(p=car(cdr(form));NNULLP(p);p=cdr(p))
  1028.   {tmp = car(p);
  1029.    if SYMBOLP(tmp) {fl = cons(tmp,fl); al = cons(NIL,al);}
  1030.    else {fl = cons(car(tmp),fl); al = cons(car(cdr(tmp)),al);}}
  1031.  p = cdr(cdr(form));
  1032.  if NULLP(cdr(p)) p = car(p); else p = cons(sym_progn,p);
  1033.  setcdr(form,cons(reverse(fl),cons(reverse(al),cons(p,NIL))));
  1034.  setcar(form,cintern("let-internal"));
  1035.  return(form);}
  1036.    
  1037.  LISP leval_quote(args,env)
  1038.  LISP args,env;
  1039. {return(car(args));}
  1040.  
  1041. LISP leval_tenv(args,env)
  1042.  LISP args,env;
  1043. {return(env);}
  1044.  
  1045. LISP symbolconc(args)
  1046.      LISP args;
  1047. {long size;
  1048.  LISP l,s;
  1049.  size = 0;
  1050.  tkbuffer[0] = 0;
  1051.  for(l=args;NNULLP(l);l=cdr(l))
  1052.    {s = car(l);
  1053.     if NSYMBOLP(s) err("wta(non-symbol) to symbolconc",s);
  1054.     size = size + strlen(PNAME(s));
  1055.     if (size >  TKBUFFERN) err("symbolconc buffer overflow",NIL);
  1056.     strcat(tkbuffer,PNAME(s));}
  1057.  return(rintern(tkbuffer));}
  1058.  
  1059.  
  1060. LISP lprint(exp)
  1061.  LISP exp;
  1062. {lprin1(exp);
  1063.  printf("\n");
  1064.  return(NIL);}
  1065.  
  1066. LISP lprin1(exp)
  1067.  LISP exp;
  1068. {LISP tmp;
  1069.  switch TYPE(exp)
  1070.    {case tc_nil:
  1071.       printf("()");
  1072.       break;
  1073.    case tc_cons:
  1074.       printf("(");
  1075.       lprin1(car(exp));
  1076.       for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
  1077.     {printf(" ");lprin1(car(tmp));}
  1078.       if NNULLP(tmp) {printf(" . ");lprin1(tmp);}
  1079.       printf(")");
  1080.       break;
  1081.     case tc_flonum:
  1082.       printf("%g",FLONM(exp));
  1083.       break;
  1084.     case tc_symbol:
  1085.       printf("%s",PNAME(exp));
  1086.       break;
  1087.     case tc_subr_0:
  1088.     case tc_subr_1:
  1089.     case tc_subr_2:
  1090.     case tc_subr_3:
  1091.     case tc_lsubr:
  1092.     case tc_fsubr:
  1093.     case tc_msubr:
  1094.       printf("#<SUBR(%d) %s>",TYPE(exp),(*exp).storage_as.subr.name);
  1095.       break;
  1096.     case tc_closure:
  1097.       printf("#<CLOSURE ");
  1098.       lprin1(car((*exp).storage_as.closure.code));
  1099.       printf(" ");
  1100.       lprin1(cdr((*exp).storage_as.closure.code));
  1101.       printf(">");
  1102.       break;}
  1103.  return(NIL);}
  1104.  
  1105. LISP lreadr(),lreadparen(),lreadtk(),lreadf();
  1106.  
  1107. LISP lread()
  1108. {return(lreadf(stdin));}
  1109.  
  1110.  int
  1111. flush_ws(f,eoferr)
  1112.  FILE *f;
  1113.  char *eoferr;
  1114. {int c;
  1115.  while(1)
  1116.    {c = getc(f);
  1117.     if (c == EOF) if (eoferr) err(eoferr,NIL); else return(c);
  1118.     if (isspace(c)) continue;
  1119.     return(c);}}
  1120.  
  1121. LISP lreadf(f)
  1122.  FILE *f;
  1123. {int c;
  1124.  c = flush_ws(f,(char *)NULL);
  1125.  if (c == EOF) return(eof_val);
  1126.  ungetc(c,f);
  1127.  return(lreadr(f));}
  1128.  
  1129. LISP lreadr(f)
  1130.  FILE *f;
  1131. {int c,j;
  1132.  char *p;
  1133.  c = flush_ws(f,"end of file inside read");
  1134.  switch (c)
  1135.    {case '(':
  1136.       return(lreadparen(f));
  1137.     case ')':
  1138.       err("unexpected close paren",NIL);
  1139.     case '\'':
  1140.       return(cons(sym_quote,cons(lreadr(f),NIL)));}
  1141.  p = tkbuffer;
  1142.  *p++ = c;
  1143.  for(j = 1; j<TKBUFFERN; ++j)
  1144.    {c = getc(f);
  1145.     if (c == EOF) return(lreadtk(j));
  1146.     if (isspace(c)) return(lreadtk(j));
  1147.     if (strchr("()'",c)) {ungetc(c,f);return(lreadtk(j));}
  1148.     *p++ = c;}
  1149.  err("token larger than TKBUFFERN",NIL);}
  1150.  
  1151. LISP lreadparen(f)
  1152.  FILE *f;
  1153. {int c;
  1154.  LISP tmp;
  1155.  c = flush_ws(f,"end of file inside list");
  1156.  if (c == ')') return(NIL);
  1157.  ungetc(c,f);
  1158.  tmp = lreadr(f);
  1159.  return(cons(tmp,lreadparen(f)));}
  1160.  
  1161. LISP lreadtk(j)
  1162.      long j;
  1163. {int k;
  1164.  char c,*p;
  1165.  p = tkbuffer;
  1166.  p[j] = 0;
  1167.  if (*p == '-') p+=1;
  1168.  { int adigit = 0;
  1169.    while(isdigit(*p)) {p+=1; adigit=1;}
  1170.    if (*p=='.') {
  1171.      p += 1;
  1172.      while(isdigit(*p)) {p+=1; adigit=1;}}
  1173.    if (!adigit) goto a_symbol; }
  1174.  if (*p=='e') {
  1175.    p+=1;
  1176.    if (*p=='-'||*p=='+') p+=1;
  1177.    if (!isdigit(*p)) goto a_symbol; else p+=1;
  1178.    while(isdigit(*p)) p+=1; }
  1179.  if (*p) goto a_symbol;
  1180.  return(flocons(atof(tkbuffer)));
  1181.  a_symbol:
  1182.  return(rintern(tkbuffer));}
  1183.       
  1184. LISP copy_list(x)
  1185.  LISP x;
  1186. {if NULLP(x) return(NIL);
  1187.  return(cons(car(x),copy_list(cdr(x))));}
  1188.  
  1189. LISP oblistfn()
  1190. {return(copy_list(oblist));}
  1191.  
  1192. close_open_files()
  1193. {LISP l;
  1194.  FILE *p;
  1195.  for(l=open_files;NNULLP(l);l=cdr(l))
  1196.    {p = (FILE *) PNAME(car(l));
  1197.     if (p)
  1198.       {printf("closing a file left open\n");
  1199.        fclose(p);}}
  1200.  open_files = NIL;}
  1201.  
  1202.  
  1203. LISP vload(fname)
  1204.  char *fname;
  1205. {LISP sym,form;
  1206.  FILE *f;
  1207.  printf("loading %s\n",fname);
  1208.  sym = symcons(0,NIL);
  1209.  open_files = cons(sym,open_files);
  1210.  PNAME(sym) = (char *) fopen(fname,"r");
  1211.  f = (FILE *) PNAME(sym);
  1212.  if (!f) {open_files = cdr(open_files);
  1213.       printf("Could not open file\n");
  1214.       return(NIL);}
  1215.  while(1)
  1216.    {form = lreadf(f);
  1217.     if EQ(form,eof_val) break;
  1218.     leval(form,NIL);}
  1219.  fclose(f);
  1220.  open_files = cdr(open_files);
  1221.  printf("done.\n");
  1222.  return(truth);}
  1223.  
  1224. LISP load(fname)
  1225.  LISP fname;
  1226. {if NSYMBOLP(fname) err("filename not a symbol",fname);
  1227.  return(vload(PNAME(fname)));}
  1228.  
  1229. LISP quit()
  1230. {longjmp(errjmp,2);
  1231.  return(NIL);}
  1232.  
  1233. LISP nullp(x)
  1234.  LISP x;
  1235. {if EQ(x,NIL) return(truth); else return(NIL);}
  1236.  
  1237. LISP arglchk(x)
  1238.  LISP x;
  1239. {LISP l;
  1240.  if SYMBOLP(x) return(x);
  1241.  for(l=x;CONSP(l);l=CDR(l));
  1242.  if NNULLP(l) err("improper formal argument list",x);
  1243.  return(x);}
  1244.  
  1245.  
  1246. init_subrs()
  1247. {init_subr("cons",tc_subr_2,cons);
  1248.  init_subr("car",tc_subr_1,car);
  1249.  init_subr("cdr",tc_subr_1,cdr);
  1250.  init_subr("set-car!",tc_subr_2,setcar);
  1251.  init_subr("set-cdr!",tc_subr_2,setcdr);
  1252.  init_subr("+",tc_subr_2,plus);
  1253.  init_subr("-",tc_subr_2,difference);
  1254.  init_subr("*",tc_subr_2,ltimes);
  1255.  init_subr("/",tc_subr_2,quotient);
  1256.  init_subr(">",tc_subr_2,greaterp);
  1257.  init_subr("<",tc_subr_2,lessp);
  1258.  init_subr("eq?",tc_subr_2,eq);
  1259.  init_subr("eqv?",tc_subr_2,eql);
  1260.  init_subr("assq",tc_subr_2,assq);
  1261.  init_subr("read",tc_subr_0,lread);
  1262.  init_subr("print",tc_subr_1,lprint);
  1263.  init_subr("eval",tc_subr_2,leval);
  1264.  init_subr("define",tc_fsubr,leval_define);
  1265.  init_subr("lambda",tc_fsubr,leval_lambda);
  1266.  init_subr("if",tc_msubr,leval_if);
  1267.  init_subr("begin",tc_msubr,leval_progn);
  1268.  init_subr("set!",tc_fsubr,leval_setq);
  1269.  init_subr("or",tc_msubr,leval_or);
  1270.  init_subr("and",tc_msubr,leval_and);
  1271.  init_subr("*catch",tc_fsubr,leval_catch);
  1272.  init_subr("*throw",tc_subr_2,lthrow);
  1273.  init_subr("quote",tc_fsubr,leval_quote);
  1274.  init_subr("oblist",tc_subr_0,oblistfn);
  1275.  init_subr("copy-list",tc_subr_1,copy_list);
  1276.  init_subr("gc-status",tc_lsubr,gc_status);
  1277.  init_subr("gc",tc_lsubr,user_gc);
  1278.  init_subr("load",tc_subr_1,load);
  1279.  init_subr("pair?",tc_subr_1,consp);
  1280.  init_subr("symbol?",tc_subr_1,symbolp);
  1281.  init_subr("number?",tc_subr_1,numberp);
  1282.  init_subr("let-internal",tc_msubr,leval_let);
  1283.  init_subr("let-internal-macro",tc_subr_1,let_macro);
  1284.  init_subr("symbol-bound?",tc_subr_2,symbol_boundp);
  1285.  init_subr("symbol-value",tc_subr_2,symbol_value);
  1286.  init_subr("set-symbol-value!",tc_subr_3,setvar);
  1287.  init_subr("the-environment",tc_fsubr,leval_tenv);
  1288.  init_subr("error",tc_subr_2,lerr);
  1289.  init_subr("quit",tc_subr_0,quit);
  1290.  init_subr("not",tc_subr_1,nullp);
  1291.  init_subr("null?",tc_subr_1,nullp);
  1292.  init_subr("env-lookup",tc_subr_2,envlookup);
  1293.  init_subr("reverse",tc_subr_1,reverse);
  1294.  init_subr("symbolconc",tc_lsubr,symbolconc);}
  1295.